home *** CD-ROM | disk | FTP | other *** search
/ Amiga Collections: Franz PD / Franz PD Disk #067 (1990-04)(Amiga User Group Deutschland e.V.).zip / Franz PD Disk #067 (1990-04)(Amiga User Group Deutschland e.V.).adf / Source.zip / StanFuncs.p < prev    next >
Text File  |  1990-02-06  |  7KB  |  273 lines
  1. external;
  2.  
  3. {
  4.     Stanfuncs.p (of PCQ Pascal)
  5.     Copyright (c) 1989 Patrick Quaid
  6.  
  7.     This module handles all the standard functions.
  8. }
  9.  
  10. {$O-}
  11. {$I "Pascal.i"}
  12.  
  13.     Function LoadAddress(): TypePtr;
  14.         external;
  15.     Function Match(s : Symbols): Boolean;
  16.         external;
  17.     Function TypeCheck(t1, t2 : TypePtr): Boolean;
  18.         external;
  19.     Procedure Mismatch;
  20.         External;
  21.     Procedure Error(s : String);
  22.         external;
  23.     Function Expression() : TypePtr;
  24.         external;
  25.     Function NumberType(i : TypePtr): Boolean;
  26.         external;
  27.     Procedure NeedLeftParent;
  28.         external;
  29.     Procedure NeedRightParent;
  30.         external;
  31.     Procedure NeedNumber;
  32.         external;
  33.     Function GetLabel(): Integer;
  34.         external;
  35.     Procedure PrintLabel(l : Integer);
  36.         external;
  37.     Function Suffix(s : Integer) : Char;
  38.         external;
  39.     Procedure NextSymbol;    { io.p }
  40.         external;
  41.     Function FindID(s : String) : IDPtr;
  42.         external;
  43.     Procedure PromoteType(var f : TypePtr; o : TypePtr; r : Short);
  44.         external;
  45.     Procedure PushLongD0;
  46.         external;
  47.     Procedure PushLongA0;
  48.         External;
  49.     Procedure PopStackSpace(amount : Integer);
  50.         External;
  51.     Procedure PopLongD0;
  52.         External;
  53.  
  54. Procedure DoOpen(NameType : TypePtr; AccessMode : Short);
  55.  
  56. {
  57.     This routine handles both open and reopen, depending on the
  58. AccessMode sent to it.  This is just passed on to the DOS routine.
  59. }
  60.  
  61. var
  62.     FileType    : TypePtr;
  63.     RecSize    : Integer;
  64.     SizeType    : TypePtr;
  65. begin
  66.     if TypeCheck(NameType, StringType) then begin
  67.     PushLongD0;
  68.     if Match(Comma1) then begin
  69.         FileType := LoadAddress();
  70.         if FileType^.Object = ob_file then begin
  71.         PushLongA0;
  72.         writeln(OutFile, "\tmove.w\t#", AccessMode, ',30(a0)');
  73.         RecSize := FileType^.SubType^.Size;
  74.         writeln(OutFile, "\tmove.l\t#", RecSize, ',24(a0)');
  75.         if Match(comma1) then begin
  76.             SizeType := expression();
  77.             if not TypeCheck(SizeType, IntType) then
  78.             mismatch;
  79.             writeln(OutFile, '\tmove.l\t(sp),a0');
  80.             writeln(OutFile, '\tmove.l\td0,20(a0)');
  81.         end else
  82.             writeln(OutFile, "\tmove.l\t#128,20(a0)");
  83.         writeln(OutFile, "\tjsr\t_p%Open");
  84.         PopStackSpace(8);
  85.         end else
  86.         Error("Need a file variable");
  87.     end else begin
  88.         Error("Expecting a comma");
  89.         PopStackSpace(4);
  90.     end;
  91.     end else
  92.     Error("Expecting a string (the file name).");
  93. end;
  94.  
  95. Procedure DoSizeOf;
  96.  
  97. {
  98.     This implements the SizeOf() function.  Upon entry to this
  99. routine, we have just read the (.  We will read up to, but not
  100. including, the ).  In this case that's just the type name.
  101. }
  102.  
  103. var
  104.     ID : IDPtr;
  105. begin
  106.     if CurrSym = Ident1 then begin
  107.     ID := FindId(SymText);
  108.     if ID <> Nil then begin
  109.         if ID^.Object = obtype then
  110.         writeln(OutFile, "\tmove.l\t#", ID^.VType^.Size,    ',d0')
  111.         else
  112.         Error("Expecting a type");
  113.     end else
  114.         Error("Unknown ID");
  115.     end else
  116.     Error("Expecting an ID");
  117.     NextSymbol;
  118. end;
  119.  
  120. Procedure StdFunc(ID : IDPtr);
  121.  
  122. {
  123.     This routine handles all the standard functions.  All but
  124. open and reopen are handled in-line.
  125. }
  126.  
  127. var
  128.     ExprType    : TypePtr;
  129.     Lab        : Integer;
  130. begin
  131.     NeedLeftParent;
  132.     if ID^.Offset < 15 then
  133.     ExprType := Expression();
  134.     case ID^.Offset of
  135. {Ord} 1 : begin
  136.         if ExprType^.Object = ob_ordinal then begin
  137.         case ExprType^.Size of
  138.           1 : ID^.VType := ByteType;
  139.           2 : ID^.VType := ShortType;
  140.           4 : ID^.VType := IntType;
  141.         end;
  142.         end else
  143.         Error("Must be an ordinal type");
  144.       end;
  145. {Chr} 2 : if not NumberType(ExprType) then
  146.           NeedNumber;
  147. {Odd} 3 : begin
  148.         if not NumberType(ExprType) then
  149.         NeedNumber;
  150.         writeln(OutFile, "\tand.", Suffix(ExprType^.Size), "\t#1,d0");
  151.         writeln(OutFile, "\tsne\td0");
  152.       end;
  153. {Abs} 4 : if TypeCheck(ExprType, RealType) then begin
  154.         writeln(OutFile, "\tmove.l\t_p%MathBase,a6");
  155.         writeln(OutFile, "\tjsr\t-54(a6)");
  156.         ID^.VType := RealType;
  157.       end else begin
  158.         if not NumberType(ExprType) then
  159.         Error("Expecting a number");
  160.         lab := GetLabel();
  161.         writeln(OutFile, "\ttst.", Suffix(ExprType^.Size), "\td0");
  162.         write(OutFile, "\tbpl.s\t");
  163.         PrintLabel(lab);
  164.         writeln(OutFile);
  165.         writeln(OutFile, "\tneg.", Suffix(ExprType^.Size), "\td0");
  166.         PrintLabel(lab);
  167.         writeln(OutFile);
  168.         ID^.VType := ExprType;
  169.       end;
  170. {Succ} 5 : begin
  171.         if ExprType^.Object <> ob_ordinal then
  172.         Error("expecting an ordinal type");
  173.         writeln(OutFile, "\taddq.", Suffix(ExprType^.Size),
  174.                 "\t#1,d0");
  175.         ID^.VType := exprtype;
  176.        end;
  177. {Pred} 6 : begin
  178.         if ExprType^.Object <> ob_ordinal then
  179.         Error("expecting an ordinal type");
  180.         writeln(OutFile, "\tsubq.", Suffix(ExprType^.Size), "\t#1,d0");
  181.         ID^.VType := ExprType;
  182.        end;
  183. {ReOpen}
  184.       7 : DoOpen(ExprType, 1005);
  185. {Open}
  186.       8 : DoOpen(ExprType, 1006);
  187. {EOF} 9 : if ExprType^.Object = ob_file then begin
  188.         writeln(OutFile, "\tmove.l\td0,a0");
  189.         writeln(OutFile, "\tmove.b\t29(a0),d0");
  190.       end else
  191.         error("Expecting a file type");
  192. {Trunc}
  193.      10 : begin
  194.         if not TypeCheck(ExprType, RealType) then
  195.         Error("Expecting a real type");
  196.         writeln(OutFile, "\tmove.l\t_p%MathBase,a6");
  197.         writeln(OutFile, "\tjsr\t-30(a6)");
  198.       end;
  199. {Round}
  200.      11 : begin
  201.         if not TypeCheck(ExprType, RealType) then
  202.         Error("Expecting a real type");
  203.         writeln(OutFile, "\tmove.l\t#$80000040,d1"); { 0.5 }
  204.         writeln(OutFile, "\tmove.l\t_p%MathBase,a6");
  205.         writeln(OutFile, "\tjsr\t-66(a6)"); { add 0.5 }
  206.         writeln(OutFile, "\tjsr\t-90(a6)"); { floor }
  207.         writeln(OutFile, "\tjsr\t-30(a6)"); { fix }
  208.       end;
  209. {Float}
  210.      12 : begin
  211.         if not NumberType(ExprType) then
  212.         NeedNumber;
  213.         PromoteType(ExprType, IntType, 0);
  214.         writeln(OutFile, "\tmove.l\t_p%MathBase,a6");
  215.         writeln(OutFile, "\tjsr\t-36(a6)");
  216.       end;
  217. {Floor}
  218.      13 : begin
  219.         if not TypeCheck(ExprType, RealType) then
  220.         Error("Expected real type");
  221.         writeln(OutFile, "\tmove.l\t_p%MathBase,a6");
  222.         writeln(OutFile, "\tjsr\t-90(a6)");
  223.       end;
  224. {Ceil}
  225.      14 : begin
  226.         if not TypeCheck(ExprType, RealType) then
  227.         Error("Expected real type");
  228.         writeln(OutFile, "\tmove.l\t_p%MathBase,a6");
  229.         writeln(OutFile, "\tjsr\t-96(a6)");
  230.       end;
  231. {SizeOf}
  232.      15 : DoSizeOf;
  233. {Adr}
  234.      16 : begin
  235.         ExprType := LoadAddress();
  236.         writeln(OutFile, "\tmove.l\ta0,d0");
  237.       end;
  238. {Bit}
  239.      17 : begin
  240.         ExprType := Expression();
  241.         if not TypeCheck(ExprType, IntType) then
  242.         Error("Expecting an integer type");
  243.         writeln(OutFile, "\tmoveq.l\t#0,d1");
  244.         writeln(OutFile, "\tand.l\t#31,d0");
  245.         writeln(OutFile, "\tbset\td0,d1");
  246.         writeln(OutFile, "\tmove.l\td1,d0");
  247.       end;
  248. { Sqr }
  249.      18 : begin
  250.           ExprType := Expression;
  251.           if not TypeCheck(ExprType, RealType) then
  252.           Error("Expecting a Floating Point Type");
  253.           Writeln(OutFile, "\tmove.l\td0,d1");
  254.           Writeln(OutFile, "\tmove.l\t_p%MathBase,a6");
  255.           Writeln(OutFile, "\tjsr\t-78(a6)");
  256.       end;
  257.  { Sin, Cos }
  258.      19,
  259.      20 : begin
  260.           ExprType := Expression;
  261.           if not TypeCheck(ExprType, RealType) then
  262.           Error("Expecting a Floating Point Type");
  263.           Writeln(OutFile, "\tmove.l\td0,-(sp)");
  264.           if ID^.Offset = 19 then
  265.           Writeln(OutFile, "\tjsr\t_p%sin")
  266.           else
  267.           Writeln(OutFile, "\tjsr\t_p%cos");
  268.           Writeln(OutFile, "\taddq.l\t#4,sp");
  269.       end;
  270.     end;
  271.     NeedRightParent;
  272. end;
  273.